AOL File Library: 11,000 to 11,999/11000.zip/AOLDLs/Programmieren [Delphi - Units]/WAVEIN_ TWaveInOut/WAVEIN~1.pas

Pascal/Delphi Source File | 2014-12-20 | 8KB | 290 lines

unit WaveInOut;
{ Copyright RL Software 1997. Homepage: http://members.aol.com/DReiche202/Welcome.htm/}
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  mmsystem;

const
  WAVE_FORMAT_ADPCM  =  $0002;  //  Microsoft Corporation  */
  WAVE_FORMAT_ALAW   =  $0006;  //  Microsoft Corporation  */

type TWaveInOutInputProc = procedure( buffer: pChar; size: Integer ) of object;
type TWaveInOutPlayedProc = procedure of object;

type
  TWaveInOut = class(TComponent)
  private
    { Private-Deklarationen }
    WAVEIN:       HWAVEIN;
    WAVEOUT:      HWAVEOUT;
    WaveBuffer:   pChar;
    WBuffer1:     pChar;
    WBuffer2:     pChar;
    AktBuffer:    Integer;
    WAVEINHDR:    TWAVEHDR;
    WAVEOUTHDR:   TWAVEHDR;
    isInOpen:     Boolean;
    isOutOpen:    Boolean;
    FInputProc:   TWaveInOutInputProc;
    FPlayedProc:  TWaveInOutPlayedProc;
    FBufferSize:  Integer;
    FUnlInput:    Boolean;
    wincontrol:   TWinControl;
    procedure     SetBuffer( size: Integer );
  protected
    { Protected-Deklarationen }
    FABHandle:  THandle;
    OldWndProc: TFarProc;
    NewWndProc: Pointer;
    procedure HookWin;
    procedure UnHookWin;
    procedure HookWndProc(var Message: TMessage);
  public
    { Public-Deklarationen }
    constructor Create( AOwner: TComponent ); override;
    destructor  Destroy; override;

    procedure   OpenInput;    // initialisiert und startet Aufzeichnung
    procedure   CloseInput;   // beendet Aufzeichnung
    procedure   RequestInput; // startet erneute Aufzeichnung

    procedure   OpenOutput;   // initialisiert Player
    procedure   CloseOutput;  // beendet playing
    procedure   PlaySound( buffer: pChar; len: Integer ); // gibt Speicherbereich akustisch aus
  published
    { Published-Deklarationen }
    property OnInput:     TWaveInOutInputProc read FInputProc write FInputProc;
    property OnPlayed:    TWaveInOutPlayedProc read FPlayedProc write FPlayedProc;
    property BufferSize:  Integer read FBufferSize write SetBuffer default 4096;
    property AutoRequest: Boolean read FUnlInput write FUnlInput default False;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Extern', [TWaveInOut]);
end;

constructor TWaveInOut.Create( AOwner: TComponent );
begin
  inherited Create( AOwner );
  isInOpen    := False;
  isOutOpen   := False;
  wincontrol  := TWinControl.Create( Self );
  wincontrol.Parent := Screen.Forms[0];
  FABHandle := wincontrol.Handle;
  HookWin();
end;

destructor TWaveInOut.Destroy;
begin
  CloseInput();
  CloseOutput();
  UnHookWin();

  if ( WaveBuffer <> Nil ) and ( FBufferSize > 0 ) then
    FreeMem( WaveBuffer );
  inherited Destroy;
end;

procedure TWaveInOut.SetBuffer( size: Integer );
begin
  if WBuffer1 <> Nil then
  begin
    FreeMem( WBuffer1 );
    WBuffer1 := Nil;
  end;

  if WBuffer2 <> Nil then
  begin
    FreeMem( WBuffer2 );
    WBuffer2 := Nil;
  end;

  FBufferSize := size;
  GetMem( WBuffer1, FBufferSize );
  GetMem( WBuffer2, FBufferSize );

  if AktBuffer = 0 then
    WaveBuffer := WBuffer1
  else
    WaveBuffer := WBuffer2;
end;

procedure TWaveInOut.OpenInput;
var
  wf: TWaveFormatEx;
  res: MMRESULT;
begin
  with wf do
  begin
    wFormatTag          := WAVE_FORMAT_ALAW;
    nChannels           := 1;
    nSamplesPerSec      := 11025;
    nAvgBytesPerSec     := 11025;
    nBlockAlign         := 1;
    wBitsPerSample      := 8;
    cbSize              := SizeOf( TWaveFormatEx );
  end;

  with WAVEINHDR do
  begin
    lpData          := WaveBuffer;              { pointer to locked data buffer }
    dwBufferLength  := FBufferSize;             { length of data buffer }
    dwBytesRecorded := 0;                       { used for input only }
    dwFlags         := 0;                       { assorted flags (see defines) }
    dwLoops         := 0;                       { loop control counter }
  end;

  case waveInOpen( @WAVEIN, 0, @wf, FABHandle, 0, CALLBACK_WINDOW ) of
    MMSYSERR_NOERROR:     isInOpen := True;
  end;

  if isInOpen then
  begin
    waveInPrepareHeader( WAVEIN, @WAVEINHDR, sizeof( TWAVEHDR ) );
    waveInAddBuffer( WAVEIN, @WAVEINHDR, sizeof( TWAVEHDR ) );
    waveInStart( WAVEIN );
  end;
end;

procedure TWaveInOut.CloseInput;
begin
  if isInOpen then
  begin
    waveInStop( WAVEIN );
(*
    if assigned( FInputProc ) and ( WAVEINHDR.dwBytesRecorded > 0 ) then
       FInputProc( WaveBuffer, WAVEINHDR.dwBytesRecorded );
*)
    waveInClose( WAVEIN );
    isInOpen := False;
  end;
end;

procedure TWaveInOut.RequestInput;
begin
  if isInOpen then
  begin
    if AktBuffer = 0 then
      WAVEINHDR.lpData := WBuffer2
    else
      WAVEINHDR.lpData := WBuffer1;

    waveInPrepareHeader( WAVEIN, @WAVEINHDR, sizeof( TWAVEHDR ) );
    waveInAddBuffer( WAVEIN, @WAVEINHDR, sizeof( TWAVEHDR ) );
    waveInStart( WAVEIN );
  end;
end;

procedure TWaveInOut.OpenOutput;
var
  wf: TWaveFormatEx;
  res: MMRESULT;
begin
  with wf do
  begin
    wFormatTag          := WAVE_FORMAT_ALAW;
    nChannels           := 1;
    nSamplesPerSec      := 11025;
    nAvgBytesPerSec     := 11025;
    nBlockAlign         := 1;
    wBitsPerSample      := 8;
    cbSize              := SizeOf( TWaveFormatEx );
  end;

  case waveOutOpen( @WAVEOUT, WAVE_MAPPER, @wf, FABHandle, 0, CALLBACK_WINDOW ) of
    MMSYSERR_NOERROR:     isOutOpen := True;
  end;
end;

procedure TWaveInOut.CloseOutput;
begin
  if isOutOpen then
  begin
    waveOutClose( WAVEOUT );
    isOutOpen := False;
  end;
end;

procedure TWaveInOut.PlaySound( buffer: pChar; len: Integer );
begin
  if isOutOpen then
  begin
    with WAVEOUTHDR do
    begin
      lpData          := buffer;             { pointer to locked data buffer }
      dwBufferLength  := len;                { length of data buffer }
      dwBytesRecorded := 0;                  { used for input only }
      dwFlags         := 0;                  { assorted flags (see defines) }
      dwLoops         := 0;                  { loop control counter }
    end;

    waveOutPrepareHeader( WAVEOUT, @WAVEOUTHDR, sizeof( TWAVEHDR ) );
    waveOutWrite( WAVEOUT, @WAVEOUTHDR, sizeof( TWAVEHDR ) );
  end;
end;

procedure TWaveInOut.HookWin;
begin
  OldWndProc := TFarProc(GetWindowLong(FABHandle, GWL_WNDPROC));
  NewWndProc := MakeObjectInstance(HookWndProc);
  SetWindowLong(FABHandle, GWL_WNDPROC, LongInt(NewWndProc));
end;

procedure TWaveInOut.UnhookWin;
begin
  SetWindowLong( FABHandle, GWL_WNDPROC, LongInt(OldWndProc) );
  if assigned( NewWndProc ) then
    FreeObjectInstance( NewWndProc );
  NewWndProc := nil;
end;

procedure TWaveInOut.HookWndProc(var Message: TMessage);
var
  recorded: Integer;
begin
  with Message do
  begin
    case Msg of
      MM_WIM_DATA:
      begin
        recorded := WAVEINHDR.dwBytesRecorded;

        if FUnlInput then
          RequestInput();

        if assigned( FInputProc ) then
          FInputProc( WaveBuffer, recorded );

        if FUnlInput then
        begin
          if AktBuffer = 0 then
          begin
            WaveBuffer  := WBuffer2;
            AktBuffer   := 1;
          end
          else
          begin
            WaveBuffer  := WBuffer1;
            AktBuffer   := 0;
          end;
        end;
      end;
      MM_WOM_DONE:
      begin
        if assigned( FPlayedProc ) then
          FPlayedProc();
      end;
    end; // case .. of
    result := CallWindowProc( OldWndProc, FABHandle, Msg, wParam, lParam );
  end;
end;

end.